home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / PGM_TOOL / PREVIEW / CLP2DLFI / COMCODE.PAS < prev    next >
Pascal/Delphi Source File  |  1995-11-10  |  32KB  |  1,196 lines
  1. unit CommonCode;
  2.  
  3. interface
  4.  
  5. uses
  6.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  7.   Forms, Dialogs, StdCtrls, Buttons, Mask, DBFserver,
  8.     wAboutBx;
  9.  
  10. const MAXPARS=20;
  11.       UPARROW=38; { in KeyDown events, GetUp(),GetDown(),GetEsc() }
  12.       DNARROW=40;
  13.       ESCKEY=27;
  14.       RETKEY=13;
  15.       RETCHAR=#13;  { in KeyPress events, GetRet() }
  16.       NULLCHAR=#0;
  17.       DNCHAR=#40;
  18.       UPCHAR=#38;
  19.       ESCCHAR=#27;
  20.       MaxMiscWin=20;
  21.             MaxModify=20;
  22.       MaxWait=20;
  23.  
  24. type
  25.     WinRec=Record
  26.       wForm:Tform;
  27.         wClass:string[20];
  28.         wHandle:THandle;
  29.     top,left,width,height:integer;
  30.     end;
  31.   oTForm=Class(TForm)
  32.   public
  33.         procedure SelNext(GoForward,CheckTab:boolean);
  34.   end;
  35.   GenVars=class(TObject)
  36.       public
  37.           AtPDS:boolean;
  38.             CanBrowse:boolean;
  39.             CanBrowseModify:boolean;
  40.       CanSeePrice:boolean;
  41.             { list of 'corefile' names they can modify during browse }
  42.             CanModifyList:array [1..MaxModify] of string[10];
  43.             CanModifyCnt:integer;
  44.       { list of files they can't even view in browse }
  45.             CantViewList:array [1..MaxModify] of string[10];
  46.       TempFCnt,CantViewCnt:integer;
  47.             User:string[20];
  48.             Station:string[20];
  49.             EmpNum:string[20];
  50.       ExeSource:string[60];
  51.             CodeSource:string[2];
  52.             CompanyName:string[70];
  53.             RootDir,RootVol:string[20];
  54.             MultiLok:oDB;  { alias name }
  55.             MiscWinList:array [1..MaxMiscWin] of WinRec;
  56.             MiscWinCnt,MiscWinMatch,MiscFndCnt:integer;
  57.             MiscWinFnd:array [1..MaxMiscWin] of integer;
  58.       DebugList:array [1..200] of string[15];
  59.       DebugCnt:integer;
  60.       WaitList:array [1..MaxWait] of TButton;
  61.       WaitText:array [1..MaxWait] of String30;
  62.       { used to store BluePrint Images }
  63.         FullBP,TinyBP,PrintBP:TBitMap;
  64.       InBluePrint:boolean; { only allow one open at a time }
  65.             procedure SetAccess;
  66.             procedure AddModify(astr:string);
  67.             function  ModifyOK(astr:string):boolean;
  68.             function  CantView(astr:string):boolean;
  69.             procedure AddWin(aClass:string;aWindow:TForm);
  70.             function  FindWin(aClass,KeyElement:string):integer;
  71.             procedure ReleaseWin(aWindow:TForm);
  72.     end;
  73.  
  74.     procedure StartCommonCode;
  75.     procedure StopCommonCode;
  76.     function  ComPath(dbfname:string):string;
  77.     function  JcPath(dbfname:string):string;
  78.     function  ArPath(dbfname:string):string;
  79.     function  ApPath(dbfname:string):string;
  80.     function  GlPath(dbfname:string):string;
  81.     function  PrPath(dbfname:string):string;
  82.     function  TempPath(fname:string):string;
  83.     function frmpath(dbfname:string):string;
  84.     function  ArchPath(dbfname:string):string;
  85.     function  TempArch(dbfname:string):string;
  86.     function  Tmpfname(Ending:string):string;
  87.     function  Tmpfdbf:string;
  88.     function  NextTemp:string;
  89.     function  NumsEqual(nn1,nn2:double):boolean;
  90.     function  GetDept(depnum:string):string;
  91.     function  CutJobNo(snum:string):string;
  92.     function  nDep(dnum:string):string;
  93.     function  LongTime:string;
  94.     function  PreviousInstance:boolean;
  95.   procedure MakeInstance;
  96.   procedure ClearInstance;
  97.     procedure ClearFlagUse;
  98.   { ltype: "J" - Job locked, "R"-routcard, "I"-in process inspect.
  99.                      "F" - final inspect, "W" - window open }
  100.     procedure FlagOn( idcode,ltype:string); { call after locking record }
  101.     procedure FlagOff(idcode,ltype:string);
  102.     function  FlagGet(idcode,ltype:string):string;
  103.     procedure AccessDenied(f1,f2:string); { OKbox calls FlagGet }
  104.     function  GetProgIni(fromSection,fromKey:string):string;
  105.     procedure PutProgIni(toSection,toKey,newValue:string);
  106.     procedure Split(orgline,pchar:string;
  107.                             var resarr:array of string135;var rescnt:integer);
  108.     function  unSplit(var arr1:array of string135;delim:string;
  109.                             acnt:integer):string;
  110.     procedure LongSplit(orgline:PChar;Delim:string;resstr:tstringlist);
  111.     procedure LongunSplit(SaveTo:Pchar;delim:string;resstr:tstringlist);
  112.     procedure uzTmpDBF(var pDBF:oDB;keyexp:string);
  113.     function  StrTran(aStr,ChgPattern,ToPattern:string):String;
  114.     procedure AtSay(var tt:string;StartCol:integer;aStr:string);
  115.     procedure MouseWait;
  116.     procedure MouseGo;
  117.     function  noExt(fname:string):string;
  118.     function  iifi(abool:boolean;ret1,ret2:integer):integer;
  119.     function  iifs(abool:boolean;ret1,ret2:string):string;
  120.     function  iifd(abool:boolean;ret1,ret2:double):double;
  121.   procedure CenterForm(aform:Tform);
  122.   procedure CenterHoriz(aform:Tform);
  123.     procedure LoadFileList(DirPath,FileSkeleton:string;var files:TStringList);
  124.   procedure CopyFile(frm,too:string);
  125.     procedure ShowStatus; { must call before using SaveStatus or DebugShow }
  126.     procedure SaveStatus(SaveText:string);
  127.     procedure DebugShow(SaveText:string);
  128.   function  Pin(str1,instr2:string):boolean;  { pos()>0 }
  129.   function  uPin(str1,instr2:string):boolean;  { uppercase them first, pos()>0 }
  130.     function  GetMove(aWord:Word;tf:TForm):integer;
  131.     function  GetEsc(aWord:Word):boolean;
  132.     function  GetUp(aWord:Word):boolean;
  133.     function  GetDown(aWord:Word):boolean;
  134.     function  GetRet(var aChar:char):boolean;
  135.     procedure WaitOn(tb:TButton);
  136.     procedure WaitOff(tb:TButton);
  137.     procedure DBFbrowse(OpenExisting:string);
  138.  
  139. var Gen:GenVars;
  140.         ParsCnt:integer;
  141.     Pars:array [1..MAXPARS] of string135;
  142.  
  143. implementation
  144.  
  145. uses WinBrows;
  146.  
  147. procedure AccessDenied(f1,f2:string);
  148. begin
  149.     OKbox('Access Denied - In Use By '+FlagGet(f1,f2));
  150. end;
  151.  
  152. procedure DBFbrowse(OpenExisting:string);
  153. begin
  154.   if Gen.FindWin('Browse','')=0 then begin
  155.       if Gen.CanBrowse then begin
  156.       WinBrowse:=TWinBrowse.create(application);
  157.       if not empty(OpenExisting) then begin
  158.         WinBrowse.OpenNow(OpenExisting);
  159.       end;
  160.       end else begin
  161.         if Gen.CanModifyCnt=0 then begin
  162.         OKBox('Browse Not Available');
  163.         exit;
  164.       end    else begin
  165.         WinBrowse:=TWinBrowse.create(application);
  166.           if not empty(OpenExisting) then WinBrowse.OpenNow(OpenExisting);
  167.       end;
  168.       end;
  169.   end else WinBrowse.Show;
  170. end;
  171.  
  172. function GetRet(var aChar:char):boolean;
  173. begin
  174.   if aChar=escchar then aChar:=nullchar;
  175.   if aChar=retchar then begin
  176.       aChar:=nullchar;
  177.         Result:=true;
  178.     end else Result:=false;
  179. end;
  180.  
  181. procedure oTForm.SelNext(GoForward,CheckTab:boolean);
  182. begin
  183.     SelectNext(ActiveControl,GoForward,CheckTab);
  184. end;
  185.  
  186. function GetProgIni(fromSection,fromKey:string):string;
  187. var pSection,pKey,pDefault,Retstr,Filename:pchar;
  188. begin
  189.   pSection:=stralloc(40);
  190.   pKey:=stralloc(40);
  191.   pDefault:=stralloc(40);
  192.   Retstr:=stralloc(140);
  193.   Filename:=stralloc(60);
  194.   strpcopy(pSection,fromSection);
  195.   strpcopy(pKey,fromKey);
  196.   strpcopy(pDefault,'');
  197.   strpcopy(FileName,'precdie.ini');
  198.   GetPrivateProfileString(pSection,pKey,pDefault,
  199.     Retstr,140,FileName);
  200.   Result:=strpas(Retstr);
  201.   strdispose(pSection);
  202.   strdispose(pKey);
  203.   strdispose(pDefault);
  204.   strdispose(Retstr);
  205.   strdispose(FileName);
  206. end;
  207.  
  208. procedure PutProgIni(toSection,toKey,newValue:string);
  209. var pSection,pKey,Filename,nuValue:pchar;
  210. begin
  211.   pSection:=stralloc(40);
  212.   pKey:=stralloc(40);
  213.   Filename:=stralloc(60);
  214.   nuValue:=stralloc(60);
  215.   strpcopy(pSection,toSection);
  216.   strpcopy(pKey,toKey);
  217.   strpcopy(nuValue,newValue);
  218.   strpcopy(FileName,'precdie.ini');
  219.   WritePrivateProfileString(pSection,pKey,nuValue,FileName);
  220.   strdispose(pSection);
  221.   strdispose(pKey);
  222.   strdispose(nuValue);
  223.   strdispose(FileName);
  224. end;
  225.  
  226. function GetMove(aWord:Word;tf:TForm):integer;
  227. begin
  228.   result:=0;
  229.   if (aWord=uparrow) then begin
  230.         oTForm(tf).SelNext(false,true);
  231.         result:=-1;
  232.     end;
  233.   if ((aWord=dnarrow) or (aWord=retkey)) then begin
  234.         oTForm(tf).SelNext(true,true);
  235.         result:=1;
  236.      end;
  237. end;
  238.  
  239. function GetUp(aWord:Word):boolean;
  240. begin;
  241.   result:=(aWord=uparrow);
  242. end;
  243.  
  244. function GetEsc(aWord:Word):boolean;
  245. begin
  246.   result:=(aWord=esckey);
  247. end;
  248.  
  249. function  Pin(str1,instr2:string):boolean;  { pos()>0 }
  250. begin
  251.   result:=(pos(str1,instr2)>0);
  252. end;
  253.  
  254. function uPin(str1,instr2:string):boolean;  { pos()>0 }
  255. begin
  256.   result:=(pos(uppercase(str1),uppercase(instr2))>0);
  257. end;
  258.  
  259. function GetDown(aWord:Word):boolean;
  260. begin;
  261.   result:=((aWord=dnarrow) or (aWord=retkey));
  262. end;
  263.  
  264. procedure DebugShow(SaveText:string);
  265. var ii:integer;
  266. begin
  267.   with setupbox do begin
  268.       listbox1.items.add(SaveText);
  269.       ii:=0;
  270.       if listbox1.items.count>13 then ii:=listbox1.items.count-13;
  271.       listbox1.topindex:=ii;
  272.   end;
  273. end;
  274.  
  275. procedure SaveStatus(SaveText:string);
  276. var ii,seln:Integer;
  277.     tt:string;
  278. begin
  279.   if Gen.DebugCnt<200 then begin
  280.     pp(Gen.DebugCnt);
  281.     Gen.DebugList[Gen.DebugCnt]:=SaveText;
  282.   end;
  283.   for ii:=1 to MaxDBFs do begin
  284.     if Gen.DebugCnt<200 then begin
  285.       DoEvents2;
  286.       tt:=dbSelectArea(ii);
  287.       if not empty(tt) then begin
  288.         pp(Gen.DebugCnt);
  289.         Gen.DebugList[Gen.DebugCnt]:=tt;
  290.       end;
  291.     end;
  292.   end;
  293. end;
  294.  
  295. procedure ShowStatus;
  296. begin
  297.   if Gen.FindWin('System Status','')=0 then
  298.       setupbox:=tsetupbox.create(application);
  299.   setupbox.show;
  300. end;
  301.  
  302. procedure LoadFileList(DirPath,FileSkeleton:string;var files:TStringList);
  303. var srch:TsearchRec;
  304.     ii:integer;
  305. begin
  306.   files.clear;
  307.     if copy(DirPath,length(DirPath),1)<>'\' then DirPath:=DirPath+'\';
  308.   ii:=findfirst(DirPath+FileSkeleton,faAnyFile,srch);
  309.   files.sorted:=true;
  310.   while ii=0 do begin
  311.       files.add(srch.name);
  312.     ii:=findnext(srch);
  313.   end;
  314. end;
  315.  
  316. procedure AtSay(var tt:string;StartCol:integer;aStr:string);
  317. var ii:integer;
  318. begin
  319.   ii:=length(tt);
  320.     if ii<StartCol then tt:=tt+space(StartCol-ii);
  321.   ii:=length(tt);
  322.     if ii>StartCol then tt:=copy(tt,1,ii);
  323.     tt:=tt+astr;
  324. end;
  325.  
  326. procedure CenterForm(aform:Tform);
  327. var ii:integer;
  328. { only for non-MDI forms }
  329. begin
  330.   aform.top:=(screen.height-aform.height) div 2;
  331.   ii:=(screen.width-aform.width-8) div 2;
  332.   if ii<0 then aform.left:=0 else aform.left:=ii;
  333. end;
  334.  
  335. procedure CenterHoriz(aform:Tform);
  336. var ii:integer;
  337. begin
  338.   ii:=(screen.width-aform.width-8) div 2;
  339.   if ii<0 then aform.left:=0 else aform.left:=ii;
  340. end;
  341.  
  342. procedure MouseWait;
  343. begin
  344.   Screen.Cursor:=crHourGlass;
  345.   Application.ProcessMessages;
  346. end;
  347.  
  348. procedure MouseGo;
  349. begin
  350.   Screen.Cursor:=crDefault;
  351.   Application.ProcessMessages;
  352. end;
  353.  
  354. function compath(dbfname:string):string;
  355. begin
  356.   Result:=dbfname;
  357.     if length(Gen.RootDir)>0 then
  358.         Result:=Gen.RootVol+Gen.RootDir+'comdat\'+dbfname;
  359. end;
  360.  
  361. function frmpath(dbfname:string):string;
  362. begin
  363.   Result:=dbfname;
  364.     if length(Gen.RootDir)>0 then
  365.         Result:=Gen.RootVol+Gen.RootDir+'forms\'+dbfname;
  366. end;
  367.  
  368. function jcpath(dbfname:string):string;
  369. begin
  370.   Result:=dbfname;
  371.     if length(Gen.RootDir)>0 then
  372.         Result:=Gen.RootVol+Gen.RootDir+'jcdat\'+dbfname;
  373. end;
  374.  
  375. function PreviousInstance:boolean;
  376. var tt,tt2:string;
  377. begin
  378.   tt2:=gen.user;  { must keep track of active user when diff from actual }
  379.   Gen.User:=GetEnv('USER');
  380.   tt:=tmpfname(Gen.CodeSource)+'.txt';
  381.   Gen.User:=tt2;
  382.   Result:=FileExists(tt);
  383. end;
  384.  
  385. procedure MakeInstance;
  386. var tt,tt2:string;
  387.     prhandle:integer;
  388. begin
  389.   tt2:=gen.user;  { must keep track of active user when diff from actual }
  390.   Gen.User:=GetEnv('USER');
  391.   tt:=tmpfname(Gen.CodeSource)+'.txt';
  392.   Gen.User:=tt2;
  393.   if not FileExists(tt) then begin
  394.       prHandle:=FileCreate(tt);
  395.       FileClose(prHandle);
  396.   end;
  397. end;
  398.  
  399. procedure ClearInstance;
  400. var tt,tt2:string;
  401. begin
  402.   tt2:=gen.user;  { must keep track of active user when diff from actual }
  403.   Gen.User:=GetEnv('USER');
  404.   tt:=tmpfname(Gen.CodeSource)+'.txt';
  405.   Gen.User:=tt2;
  406.   if FileExists(tt) then DeleteFile(tt);
  407. end;
  408.  
  409. function tmpfname(Ending:string):string;
  410. var fname:string[20];
  411. begin
  412.   fname:=trim(copy(Gen.User,1,3))+
  413.       trim(copy(Gen.Station,length(Gen.Station)-2,3))+trim(Ending);
  414.   Result:=fname;
  415.     if length(Gen.RootDir)>0 then
  416.         Result:=Gen.RootVol+Gen.RootDir+'tmpdir\'+fname;
  417. end;
  418.  
  419. function tmpfdbf:string;
  420. var fname:string[20];
  421. begin
  422.   fname:=trim(copy(Gen.User,1,3))+
  423.       trim(copy(Gen.Station,length(Gen.Station)-2,3));
  424.   Result:=fname;
  425.     if length(Gen.RootDir)>0 then
  426.         Result:=Gen.RootVol+Gen.RootDir+'tmpdir\'+GetUniqueAlias(fname);
  427. end;
  428.  
  429. function  StrTran(aStr,ChgPattern,ToPattern:string):String;
  430. var tparscnt:integer;
  431.     tpars:array [1..MAXPARS] of string135;
  432. begin
  433.   split(aStr,ChgPattern,tpars,tparscnt);
  434.   Result:=unsplit(tpars,ToPattern,tparscnt);
  435. end;
  436.  
  437. function NextTemp:string;
  438. begin
  439.   pp(Gen.TempFCnt);
  440.   if Gen.Tempfcnt>40 then Gen.tempfcnt:=1;
  441.   Result:=tmpfname(inttostr(Gen.tempfcnt)+'.txt');
  442. end;
  443.  
  444. function arpath(dbfname:string):string;
  445. begin
  446.   Result:=dbfname;
  447.     if length(Gen.RootDir)>0 then
  448.         Result:=Gen.RootVol+Gen.RootDir+'ardat\'+dbfname;
  449. end;
  450.  
  451. function appath(dbfname:string):string;
  452. begin
  453.   Result:=dbfname;
  454.     if length(Gen.RootDir)>0 then
  455.         Result:=Gen.RootVol+Gen.RootDir+'apdat\'+dbfname;
  456. end;
  457.  
  458. function glpath(dbfname:string):string;
  459. begin
  460.   Result:=dbfname;
  461.     if length(Gen.RootDir)>0 then
  462.         Result:=Gen.RootVol+Gen.RootDir+'gldat\'+dbfname;
  463. end;
  464.  
  465. function prpath(dbfname:string):string;
  466. begin
  467.   Result:=dbfname;
  468.     if length(Gen.RootDir)>0 then
  469.         Result:=Gen.RootVol+Gen.RootDir+'prdat\'+dbfname;
  470. end;
  471.  
  472. function archpath(dbfname:string):string;
  473. begin
  474.   Result:=dbfname;
  475.     if length(Gen.RootDir)>0 then
  476.         Result:=Gen.RootVol+'\accting\archive\'+dbfname;
  477. end;
  478.  
  479. function TempPath(fname:string):string;
  480. begin
  481.   Result:=fname;
  482.     if length(Gen.RootDir)>0 then begin
  483.         Result:=Gen.RootVol+Gen.RootDir+'tmpdir\'+fname;
  484.   end;
  485. end;
  486.  
  487. function temparch(dbfname:string):string;
  488. begin
  489.   Result:=dbfname;
  490.     if length(Gen.RootDir)>0 then
  491.         Result:=Gen.RootVol+'\accting\temparch\'+dbfname;
  492. end;
  493.  
  494. procedure GenVars.AddModify(astr:string);
  495. var ii:integer;
  496. begin
  497.     split(trim(astr),' ',pars,parscnt);
  498.     for ii:=1 to parscnt do begin
  499.         if CanModifyCnt<MaxModify then begin
  500.           pp(CanModifyCnt);
  501.             CanModifyList[CanModifyCnt]:=upper(pars[ii]);
  502.         end;
  503.     end;
  504. end;
  505.  
  506. function GenVars.ModifyOK(astr:string):boolean;
  507. var ii:integer;
  508. begin
  509.   Result:=false;
  510.     astr:=upper(astr);
  511.     if CanModifyCnt>0 then begin
  512.         for ii:=1 to CanModifyCnt do begin
  513.           if astr=CanModifyList[ii] then begin
  514.               Result:=true;
  515.                 break;
  516.             end;
  517.         end;
  518.     end;
  519. end;
  520.  
  521. function GenVars.CantView(astr:string):boolean;
  522. var ii:integer;
  523. begin
  524.   Result:=false;
  525.     astr:=upper(astr);
  526.     if CantViewCnt>0 then begin
  527.         for ii:=1 to CantViewCnt do begin
  528.           if astr=CantViewList[ii] then begin
  529.               Result:=true;
  530.                 break;
  531.             end;
  532.         end;
  533.     end;
  534. end;
  535.  
  536. procedure GenVars.SetAccess;
  537. begin
  538.   CanSeePrice:=False;
  539.     CanBrowse:=False;
  540.     if pin(user,'BRAD DIANNE TONY CONNIE MARY ')
  541.     then CanBrowse:=True;
  542.     CanBrowseModify:=False;
  543.     if pin(User,'BRAD DIANNE CONNIE MARY ') then CanBrowseModify:=True;
  544.   if pin(User,'JOHN CONNIE BRAD TONY BEN JEFF GEORGE DIANNE ') then
  545.       CanSeePrice:=True;
  546.     { setup which files they can make changes to }
  547.   CantViewList[1]:='EMP'; { nobody can browse emp.dbf }
  548.   CantViewList[2]:='CHART'; { nobody can browse emp.dbf }
  549.     CantViewCnt:=2;
  550.     if pin(user,'BRAD MARY ') then CantViewCnt:=0;
  551.     CanModifyCnt:=0;
  552.   if pin(User,'SONIA ') then begin
  553.       AddModify('custfax tlabor time');
  554.     end;
  555.   if pin(User,'CARL ') then begin
  556.       AddModify('parts cust vendors routcard routspec inprocess ipidata');
  557.     end;
  558. end;
  559.  
  560. function numsequal(nn1,nn2:double):boolean;  { NUMSEQUAL }
  561. var nst1,nst2:string[20];
  562. { compare numbers for exact equality }
  563. begin
  564.   nst1:=Copy(transform(nn1,'9999999.99999'),1,12);
  565.   nst2:=Copy(transform(nn2,'9999999.99999'),1,12);
  566.   Result:=(nst1=nst2);
  567. end;
  568.  
  569.  
  570. function cutjobno(snum:string):string;  { CUTJOBNO }
  571. var i1,i2:integer;
  572.     tj:string[30];
  573. begin
  574.   { return Job No from Inv. No. or Shipper No. }
  575.   i2:=0;
  576.   for i1:=1 to length(snum) do begin  { look for last hyphen in number }
  577.     if Copy(snum,i1,1)='-' then begin
  578.       i2:=i1;
  579.     End;
  580.   End;
  581.   if i2>1 then begin
  582.     tj:=Copy(snum,1,i2-1);
  583.   End Else
  584.   Begin
  585.     tj:=Copy(snum,1,8);
  586.   End;
  587.   if length(tj)<10 then begin
  588.     tj:=tj+space(11);
  589.     tj:=Copy(tj,1,10);
  590.   End;
  591.   Result:=tj;
  592. end;
  593.  
  594.  
  595. function ndep(dnum:string):string;  { NDEP }
  596. const maxdep=31;
  597. var ddi,ddj:integer;
  598.     depno:array [1..maxdep] of string[4];
  599.         deptitle:array [1..maxdep] of string[30];
  600.  
  601.   procedure setdep(inum:integer;depnum,title:string);
  602.     begin
  603.       depno[inum]:=depnum;
  604.       deptitle[inum]:=title;
  605.     end;
  606.  
  607. begin
  608.   setdep( 1,'100','Supervisor');
  609.   setdep( 2,'11 ','Design');
  610.   setdep( 3,'12 ','Quality Control');
  611.   setdep( 4,'14 ','Die');
  612.   setdep( 5,'15 ','Gage');
  613.   setdep( 6,'16 ','Stamping');
  614.   setdep( 7,'17 ','Jig Bore / Machining');
  615.   setdep( 8,'18 ','Jig Grinding');
  616.   setdep( 9,'19 ','Wire EDM');
  617.   setdep(10,'200','Equipment Maint.');
  618.   setdep(11,'21 ','Temporary Help');
  619.   setdep(12,'3  ','Clerical');
  620.   setdep(13,'300','Clean Up');
  621.   setdep(14,'400','General Shop');
  622.   setdep(15,'5  ','Purchasing');
  623.   setdep(16,'500','Driving');
  624.   setdep(17,'600','Medical Time Off');
  625.   setdep(18,'700','Training / Education');
  626.   setdep(19,'800','Over-Run Inventory');
  627.   setdep(20,'9  ','Machine Maint.');
  628.     if Gen.AtPDS then setdep(21,'900','Prec.Gage Eq. Maint.')
  629.         else setdep(22,'900','P.Die Equip. Maint.');
  630.   setdep(23,'901','Acct/Rpts/Txs/Stmts.');
  631.   setdep(24,'902','Precision Gage Work');
  632.   setdep(25,'903','Admin/Ins./Personnel');
  633.   setdep(26,'904','Clerical/Type/Filing');
  634.   setdep(27,'905','Computer Work');
  635.   setdep(28,'906','Job Quote/Update/BPS');
  636.   setdep(29,'907','Job Setup/PO''s/Info');
  637.   setdep(30,'908','Ship/Inv/Rec/Filing');
  638.   setdep(31,'909','Phone & Reception');
  639.   ddj:=0;
  640.   for ddi:=1 to maxdep do begin
  641.     if dnum=depno[ddi] then begin
  642.       ddj:=ddi;
  643.       break;
  644.     End;
  645.   End;
  646.   if ddj>0 then begin
  647.     Result:=deptitle[ddj];
  648.     end else Result:='* Dept. Unknown *';
  649. end;
  650.  
  651.  
  652. function longtime:string;  { LONGTIME }
  653. var thr:integer;
  654.     tmin,ttime:string[20];
  655.     tdate:TDateTime;
  656. begin
  657.   tdate:=time;
  658.   ttime := FormatDateTime('hh:nn',tdate);
  659.   thr := strtoint(Copy(ttime,1,2));
  660.   tmin := Copy(ttime,4,2);
  661.   if thr >= 12 then begin
  662.     ttime := ' pm';
  663.     if thr>12 then begin
  664.       thr := thr-12;
  665.     End;
  666.   End Else
  667.   Begin
  668.     ttime := ' am';
  669.   End;
  670.   Result:=transform(thr,'99')+':'+tmin+ttime;
  671. end;
  672.  
  673. procedure split(orgline,pchar:string;
  674.   var resarr:array of string135;var rescnt:integer);
  675. var aline:string;
  676.     ii,jj,kk,acnt,plen:integer;
  677.         ats:array [1..80] of integer;
  678. begin
  679.   for ii:=0 to high(resarr) do resarr[ii]:='';
  680.   rescnt:=0;
  681.   for ii:=1 to 80 do ats[ii]:=0;
  682.   aline:=trim(orgline);
  683.   jj:=length(aline);
  684.   plen:=length(pchar);
  685.   if jj>0 then begin
  686.     rescnt:=1;
  687.     ats[rescnt]:=0;
  688.     for ii:=1 to jj do begin
  689.       if Copy(aline,ii,plen)=pchar then begin
  690.         pp(rescnt);
  691.         ats[rescnt]:=ii;
  692.       End;
  693.     End;
  694.     ats[rescnt+1]:=jj;
  695.     if rescnt=1 then begin
  696.       resarr[0]:=aline;
  697.     End Else
  698.     Begin
  699.       for ii:=1 to rescnt do begin
  700.         if ii=1 then begin
  701.           kk:=ats[ii+1]-ats[ii]-1;
  702.           if kk>0 then begin
  703.             resarr[ii-1]:=Copy(aline,1,kk);
  704.           End;
  705.         end else
  706.         if ii=rescnt then begin
  707.           kk:=ats[ii+1]-ats[ii]-plen+1;
  708.           if kk>0 then begin
  709.             resarr[ii-1]:=Copy(aline,ats[ii]+plen,kk);
  710.           End;
  711.         end Else
  712.         begin
  713.           kk:=ats[ii+1]-ats[ii]-plen;
  714.           if kk>0 then begin
  715.             resarr[ii-1]:=Copy(aline,ats[ii]+plen,kk);
  716.           End;
  717.         End;
  718.       End;
  719.     End;
  720.   End;
  721. end;
  722.  
  723.  
  724. function unsplit(var arr1:array of string135;delim:string;acnt:integer):string;
  725. { array may be 1 based, but when passed in it becomes 0 based }
  726. var ii,jj,pp:integer;
  727.     tt:string;
  728. begin
  729.   tt:='';
  730.   if acnt=1 then begin
  731.     tt:=arr1[0];
  732.   End;
  733.   if acnt>1 then begin
  734.     for ii:=0 to acnt-2 do begin
  735.       tt:=tt+arr1[ii]+delim;
  736.     End;
  737.     tt:=tt+arr1[acnt-1];
  738.   End;
  739.   Result:=tt;
  740. end;
  741.  
  742. procedure LongSplit(orgline:PChar;Delim:string;resstr:tstringlist);
  743. var aline,atemp,tdel,curpos,delpos:pchar;
  744.     ii,jj,plen:integer;
  745. begin
  746.   atemp:=stralloc(MaxMemoSize);  { keep track of org pointer, aline is changed }
  747.     tdel:=stralloc(2);
  748.     strpcopy(tdel,delim);
  749.     strcopy(atemp,orgline);
  750.   TrimStr(atemp);
  751.   aline:=atemp;
  752.     resstr.clear;
  753.   jj:=strlen(aline);
  754.   plen:=strlen(tdel);
  755.     delpos:=strpos(aline,tdel);
  756.     while delpos<>nil do begin
  757.       delpos^:=#0;
  758.         resstr.add(strpas(aline));
  759.         inc(aline,length(resstr[resstr.count-1])+plen);
  760.         delpos:=strpos(aline,tdel);
  761.     end;
  762.     resstr.add(strpas(aline));
  763.     strdispose(atemp);
  764.     strdispose(tdel);
  765. end;
  766.  
  767. procedure LongunSplit(SaveTo:Pchar;delim:string;resstr:tstringlist);
  768. var ii:integer;
  769.         temp:pchar;
  770. begin
  771.     temp:=stralloc(140);
  772.     strpcopy(SaveTo,'');
  773.   if resstr.count=1 then begin
  774.     strpcopy(SaveTo,resstr[0]);
  775.   End;
  776.   if resstr.count>1 then begin
  777.     for ii:=0 to resstr.count-2 do begin
  778.             strpcopy(temp,resstr[ii]);
  779.           strcat(SaveTo,temp);
  780.             strpcopy(temp,delim);
  781.           strcat(SaveTo,temp);
  782.     End;
  783.         strpcopy(temp,resstr[resstr.count-1]);
  784.         strcat(SaveTo,temp);
  785.   End;
  786.     strdispose(temp);
  787. end;
  788.  
  789. procedure uztmpdbf(var pDBF:oDB;keyexp:string);
  790. var    dn,tt,tt2:string;
  791.     ii:integer;
  792.         fn,ft:array [1..10] of string;
  793.         fw,fd:array [1..10] of integer;
  794. begin
  795.   dn:='';
  796.   for ii:=1 to 20 do begin
  797.         tt2:=tmpfdbf+inttostr(ii);
  798.         tt:=CoreFile(tt2);
  799.         if dbSelect(tt)=0 then begin
  800.             if FileExists(tt2+'.dbf') then DeleteFile(tt2+'.dbf');
  801.             if FileExists(tt2+'.cdx') then DeleteFile(tt2+'.cdx');
  802.             dn:=tt2;
  803.             break;
  804.         end;
  805.   end;
  806.     if empty(dn) then begin
  807.       OKBox('Unable To Open Temp DBF '+tt2);
  808.     end else begin
  809.         fn[1]:='emp_no';   ft[1]:='C';  fw[1]:=3;    fd[1]:=0;
  810.         fn[2]:='part_no';  ft[2]:='C';  fw[2]:=20;   fd[2]:=0;
  811.         fn[3]:='job_no';   ft[3]:='C';  fw[3]:=10;   fd[3]:=0;
  812.         fn[4]:='po_no';    ft[4]:='C';  fw[4]:=15;   fd[4]:=0;
  813.         fn[5]:='cust_no';  ft[5]:='C';  fw[5]:=6;    fd[5]:=0;
  814.         fn[6]:='idx_key';  ft[6]:='C';  fw[6]:=30;   fd[6]:=0;
  815.         fn[7]:='rec_no';   ft[7]:='N';  fw[7]:=8;    fd[7]:=0;
  816.         fn[8]:='hours';    ft[8]:='N';  fw[8]:=9;    fd[8]:=2;
  817.         fn[9]:='recs';     ft[9]:='C';  fw[9]:=120;  fd[9]:=0;
  818.         fn[10]:='jobarr';  ft[10]:='N'; fw[10]:=7;   fd[10]:=0;
  819.         CreateDBF(dn,10,fn,ft,fw,fd);
  820.         { tag name and key expression }
  821.         dbUseExclusive(pDBF,dn);
  822.         pDBF.CreateIndex(pDBF.Alias,keyexp);
  823.         dbClose(pDBF);
  824.         dbUseExclusive(pDBF,dn);
  825.     end;
  826. end;
  827.  
  828. function GetDept(depnum:string):string;
  829. begin
  830.   Result:='';
  831.   if depnum='11 ' then Result:='Design';
  832.   if depnum='12 ' then Result:='Quality Control';
  833.   if depnum='14 ' then Result:='Die';
  834.   if depnum='15 ' then Result:='Gage';
  835.   if depnum='16 ' then Result:='Stamping';
  836.   if depnum='17 ' then Result:='Jig Bore/Machining';
  837.   if depnum='18 ' then Result:='Jig Grinding';
  838.   if depnum='19 ' then Result:='Wire EDM';
  839. end;
  840.  
  841. function FlagGet(idcode,ltype:string):string;
  842. var tv:string[30];
  843.     oarea:boolean;
  844. begin
  845.   { also see AccessDenied() }
  846.   oarea:=dbIsClosed(Gen.Multilok);
  847.   if oarea then dbUse(Gen.Multilok,compath('multilok'));
  848.   tv:=padr(trim(upper(idcode)),20);
  849.     ltype:=upper(ltype);
  850.     Result:='';
  851.     if Gen.Multilok.Seek(tv+ltype) then begin
  852.         Result:=trim(Gen.Multilok.s('lockedby'));
  853.     end;
  854.   if oarea then dbClose(gen.multilok);
  855. end;
  856.  
  857. procedure ClearFlagUse;
  858. var ii:integer;
  859.     oarea:boolean;
  860.     emptyst,tname:string[30];
  861. begin
  862.   tname:=padr(Gen.User,10);
  863.   oarea:=dbIsClosed(gen.multilok);
  864.   if oarea then dbUse(Gen.Multilok,compath('multilok'));
  865.     with Gen.Multilok do begin
  866.         setorder(0);
  867.     gotop;
  868.         while not eof do begin
  869.             if pin(Gen.User,s('lockedby')) then begin
  870.                 Lock;
  871.                 ss('lock_id',' ');
  872.                 ss('lock_type',' ');
  873.                 ss('lockedby',' ');
  874.                 ss('locksource',' ');  { 2 letter code for program it came from }
  875.                 dd('dated',0);
  876.                 ss('attime',' ');
  877.                 unLock;
  878.             end;
  879.             skip;
  880.         end;
  881.         setorder(1);
  882.     end;
  883.   if oarea then dbclose(gen.multilok);
  884. end;
  885.  
  886. procedure FlagOn(idcode,ltype:string);
  887. var oarea:boolean;
  888.     emptyst,tv,tname:string[30];
  889. begin
  890.   { ltype codes: "W"-Window open,  new types will need change in aboutbox
  891.                                  "R"-Routcard
  892.                                  "J"-Job Setup Change
  893.                    "I"-In-process inspect.
  894.                    "F"-Final inspect.
  895.                    "S"-Shipper
  896.                  "Q"-Shipper Request   }
  897.   tname:=padr(Gen.User,10);
  898.   oarea:=dbIsClosed(gen.multilok);
  899.   if oarea then dbUse(Gen.Multilok,compath('multilok'));
  900.   tv:=padr(trim(upper(idcode)),20);
  901.     ltype:=upper(ltype);
  902.     emptyst:=space(20);
  903.     with Gen.Multilok do begin
  904.         if Seek(tv+ltype) then begin
  905.           lock;
  906.         end else begin
  907.             if Seek(emptyst) then begin
  908.                 if not aLock then Append;
  909.             End Else
  910.             Begin
  911.                 Append;
  912.             End;
  913.         end;
  914.         ss('lock_id',tv);
  915.         ss('lock_type',ltype);
  916.         ss('lockedby',Gen.User);
  917.         dd('dated',xDate);
  918.         ss('attime',longtime);
  919.         ss('locksource',Gen.CodeSource);
  920.         unLock;
  921.     end;
  922.   if oarea then dbclose(gen.multilok);
  923. end;
  924.  
  925. procedure FlagOff(idcode,ltype:string);
  926. var oarea:boolean;
  927.     tv,tname:string[30];
  928. begin
  929.   { a false return would mean possible corruption }
  930.   { a P/N or Job No, ltype="R"-routcard, "I"-in process inspect. }
  931.     oarea:=dbIsClosed(Gen.Multilok);
  932.   if oarea then dbUse(Gen.Multilok,compath('multilok'));
  933.   tname:=padr(Gen.User,10);
  934.   tv:=padr(trim(upper(idcode)),20);
  935.     ltype:=upper(ltype);
  936.     with Gen.Multilok do begin
  937.         if Seek(tv+ltype) then begin
  938.             Lock;
  939.             ss('lock_id',' ');
  940.             ss('lock_type',' ');
  941.             ss('lockedby',' ');
  942.             ss('locksource',' ');
  943.             dd('dated',0);
  944.             ss('attime',' ');
  945.             unLock;
  946.         end;
  947.     end;
  948.   if oarea then dbclose(gen.multilok);
  949. end;
  950.  
  951. procedure CopyFile(frm,too:string);
  952. var p1,p2,p3:pchar;
  953.         ret,outfile,infile:integer;
  954.         bsize:word;
  955. begin
  956.   if FileExists(too) then DeleteFile(too);
  957.     p1:=stralloc(130);
  958.     p2:=stralloc(130);
  959.   p3:=stralloc(1024);
  960.     StrPCopy(p1,frm);
  961.     strpcopy(p2,too);
  962.   infile:=_lopen(p1,0);
  963.   outfile:=filecreate(too);
  964.   if (infile>0) and (outfile>0) then begin
  965.     bsize:=_lread(infile,p3,1024);
  966.     while bsize=1024 do begin
  967.       ret:=_lwrite(outfile,p3,bsize);
  968.       if ret<0 then begin
  969.         bsize:=0;
  970.         break;
  971.       end;
  972.       bsize:=_lread(infile,p3,1024);
  973.     end;
  974.     if bsize>0 then _lwrite(outfile,p3,bsize);
  975.   end;
  976.   if infile>0 then _lclose(infile)
  977.   else begin
  978.     OKbox('CopyFile() Error: '+inttostr(infile)+' Opening '+frm)
  979.   end;
  980.   if outfile>0 then _lclose(outfile)
  981.   else begin
  982.     OKbox('CopyFile() Error: '+inttostr(outfile)+' Creating '+too)
  983.   end;
  984.     strdispose(p1);
  985.     strdispose(p2);
  986.     strdispose(p3);
  987. end;
  988.  
  989. function GenVars.FindWin(aClass,KeyElement:string):integer;
  990. var ii:integer;
  991.     tt:string;
  992. begin
  993.   MiscWinMatch:=0;
  994.   MiscFndCnt:=0;
  995.   if MiscWinCnt>0 then begin
  996.    aClass:=upper(trim(aClass));
  997.    KeyElement:=upper(trim(KeyElement));
  998.       for ii:=1 to MiscWinCnt do begin
  999.         if aClass=MiscWinList[ii].wClass then begin
  1000.         pp(MiscFndCnt);
  1001.         MiscWinFnd[MiscFndCnt]:=ii;
  1002.                 tt:=upper(MiscWinList[ii].wForm.Caption);
  1003.         if (not empty(KeyElement)) then begin
  1004.           { find exact match }
  1005.           if pin(KeyElement,tt) then begin
  1006.               if MiscWinMatch=0 then MiscWinMatch:=ii;
  1007.           end;
  1008.         end else begin
  1009.           { find first occurance }
  1010.              if MiscWinMatch=0 then MiscWinMatch:=ii;
  1011.         end;
  1012.       end;
  1013.     end;
  1014.   end;
  1015.   Result:=MiscWinMatch;
  1016. end;
  1017.  
  1018. procedure GenVars.AddWin(aClass:string;aWindow:TForm);
  1019. begin
  1020.   if MiscWinCnt<MaxMiscWin then begin
  1021.     pp(MiscWinCnt);
  1022.     with MiscWinlist[MiscWinCnt] do begin
  1023.             wForm:=aWindow;
  1024.             wClass:=upper(aClass);
  1025.             wHandle:=aWindow.handle;
  1026.       top:=aWindow.top;
  1027.       left:=aWindow.left;
  1028.       width:=aWindow.width;
  1029.       height:=aWindow.height;
  1030.         end;
  1031.         FlagOn(trim(Gen.User)+':'+aclass,'W');
  1032.   end;
  1033. end;
  1034.  
  1035. procedure GenVars.ReleaseWin(aWindow:TForm);
  1036. var ii,jj,kk:integer;
  1037. begin
  1038.   jj:=0;
  1039.   if MiscWinCnt>0 then begin
  1040.        for ii:=1 to MiscWinCnt do begin
  1041.         if MiscWinList[ii].wHandle=aWindow.handle then begin
  1042.         jj:=ii;
  1043.                 FlagOff(trim(Gen.User)+':'+MiscWinList[jj].wclass,'W');
  1044.         break;
  1045.       end;
  1046.     end;
  1047.   end;
  1048.     if jj>0 then begin
  1049.         { shuffle everything up one spot }
  1050.         kk:=0;
  1051.         for ii:=1 to MiscWinCnt do begin
  1052.             if ii<>jj then begin
  1053.                 pp(kk);
  1054.                 MiscWinList[kk].wForm:=MiscWinList[ii].wForm;
  1055.                 MiscWinList[kk].wClass:=MiscWinList[ii].wClass;
  1056.                 MiscWinList[kk].wHandle:=MiscWinList[ii].wHandle;
  1057.                 MiscWinList[kk].top:=MiscWinList[ii].top;
  1058.                 MiscWinList[kk].left:=MiscWinList[ii].left;
  1059.                 MiscWinList[kk].width:=MiscWinList[ii].width;
  1060.                 MiscWinList[kk].height:=MiscWinList[ii].height;
  1061.             end;
  1062.         end;
  1063.         MiscWinCnt:=kk;
  1064.     end;
  1065. end;
  1066.  
  1067. procedure WaitOn(tb:TButton);
  1068. var ii:integer;
  1069. begin
  1070.   for ii:=1 to MaxWait do begin
  1071.     if gen.WaitList[ii]=nil then begin
  1072.       gen.Waitlist[ii]:=tb;
  1073.       gen.WaitText[ii]:=tb.caption;
  1074.       tb.caption:='Wait';
  1075.       tb.enabled:=false;
  1076.       break;
  1077.     end;
  1078.   end;
  1079. end;
  1080.  
  1081. procedure WaitOff(tb:TButton);
  1082. var ii:integer;
  1083. begin
  1084.   for ii:=1 to MaxWait do begin
  1085.     if gen.WaitList[ii]=tb then begin
  1086.       gen.WaitList[ii]:=nil;
  1087.       tb.caption:=gen.WaitText[ii];
  1088.       tb.enabled:=true;
  1089.       break;
  1090.     end;
  1091.   end;
  1092. end;
  1093.  
  1094. function noext(fname:string):string;  { NOEXT  return file name minus extension }
  1095. var ii:integer;
  1096. begin
  1097.   ii:=pos('.',fname);
  1098.   if ii>1 then begin
  1099.     Result:=Copy(fname,1,ii-1);
  1100.   End Else
  1101.   Begin
  1102.     Result:=fname;
  1103.   End;
  1104. end;
  1105.  
  1106. function iifi(abool:boolean;ret1,ret2:integer):integer;
  1107. {  iif() when params are integer's }
  1108. begin
  1109.   if abool then result:=ret1 else result:=ret2;
  1110. end;
  1111.  
  1112. function iifs(abool:boolean;ret1,ret2:string):string;
  1113. {  iif() when params are string's }
  1114. begin
  1115.   if abool then result:=ret1 else result:=ret2;
  1116. end;
  1117.  
  1118. function iifd(abool:boolean;ret1,ret2:double):double;
  1119. {  iif() when params are double's }
  1120. begin
  1121.   if abool then result:=ret1 else result:=ret2;
  1122. end;
  1123.  
  1124. procedure StartCommonCode;
  1125. var ii:integer;
  1126.     tt:string;
  1127.     ddb:oDB;
  1128. begin
  1129.   Gen:=GenVars.Create;
  1130.   with Gen do begin
  1131.       CodeSource:='JC';
  1132.     MiscWinCnt:=0;
  1133.     User:='';
  1134.     TempFCnt:=0;
  1135.     ExeSource:=paramstr(0);
  1136.     User:=upper(getenv('user'))+' ';
  1137.     RootVol:='\\prec_die\sys';
  1138.     RootDir:='\accting\';
  1139.     EmpNum:=upper(getenv('empnum'));
  1140.     if empty(EmpNum) then EmpNum:='001';
  1141.     Station:=upper(getenv('station'));
  1142.     if pin('0012',Station) then begin
  1143.       RootVol:='d:';
  1144.       RootDir:='\accting\';
  1145.     end;
  1146.     if pin(gen.user,'TONY ') then RootVol:='f:';
  1147.     if Gen.User='BRAD ' then begin
  1148.       if not pin('0012',Station) then begin
  1149.         if YesNoBox('Use Test Data ([No] Actual Data)') then begin
  1150.           RootDir:='\accttest\';
  1151.         end;
  1152.         tt:=inputbox('Run As User','Enter User Name','');
  1153.         if not empty(tt) then gen.user:=upper(tt)+' ';
  1154.       end;
  1155.     end;
  1156.     if empty(user) then begin
  1157.       user:='BRAD ';
  1158.       RootVol:='';
  1159.       RootDir:='';
  1160.     end;
  1161.     multilok:=nil;
  1162.     ddb:=nil;
  1163.     { since this routine is only run once, don't need to use DataSet method }
  1164.     dbUse(Multilok,compath('multilok'));  { should always be open }
  1165.     AtPDS:=true;
  1166.     CompanyName:='';
  1167.     if not empty(rootdir) then begin
  1168.       dbUse(ddb,compath('company'));
  1169.       AtPDS:=ddb.b('at_company');
  1170.       dbClose(ddb);
  1171.       dbUse(ddb,jcpath('control'));
  1172.       CompanyName:=ddb.st('company');
  1173.       dbClose(ddb);
  1174.     end;
  1175.     DebugCnt:=0;
  1176.     SetAccess;
  1177.     for ii:=1 to MaxWait do Waitlist[ii]:=nil;
  1178.     FullBP:=TBitMap.create;
  1179.     TinyBP:=TBitMap.create;
  1180.     PrintBP:=TBitMap.create;
  1181.     InBluePrint:=false;
  1182.   end;
  1183. end;
  1184.  
  1185. procedure StopCommonCode;
  1186. begin
  1187.   Gen.FullBP.free;
  1188.   Gen.TinyBP.free;
  1189.   Gen.PrintBP.free;
  1190.   gen.free;
  1191. end;
  1192.  
  1193.  
  1194. end.
  1195.  
  1196.